home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / token.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  10.0 KB  |  370 lines  |  [TEXT/CCL2]
  1. ;;;  This file abstracts the representation of tokens.  It is used by both
  2. ;;;  the lexer & parser.  This also contains routines for converting
  3. ;;;  individual tokens to ast structure.  Routines used by the
  4. ;;;  token-case macro in `satisfies' clauses are here too.
  5.  
  6. ;;; Lexer routines for emitting tokens:
  7.  
  8. (define (emit-token type . args)
  9.   (cond (*on-new-line?*
  10.      (push (list 'line *start-line* *start-col*) *tokens*))
  11.     (*save-col?*
  12.      (push (list 'col *start-col*) *tokens*)))
  13.   (push (cons type args) *tokens*)
  14.   (setf *on-new-line?* '#f)
  15.   (setf *save-col?* (memq type '(|where| |of| |let| begin-annotation))))
  16.  
  17. (define (emit-token/string type string-as-list)
  18.   (emit-token type (list->string string-as-list)))
  19.  
  20. ;;; Parser routines:
  21.  
  22. ;;;  These routines take care of the token stream in the parser.  They
  23. ;;;  maintain globals for the current token and its location.  
  24.  
  25. ;;;  Globals used:
  26. ;;;   *token-stream*   remaining tokens to be parsed
  27. ;;;   *token*          current token type
  28. ;;;   *token-args*     current token arguments
  29. ;;;   *layout-stack*   columns at which layout is being done
  30. ;;;   *current-line*   current line the scanner is on
  31. ;;;   *current-col*    current col; valid at start of line & after where,let,of
  32. ;;;   *current-file*
  33.  
  34. (define (init-token-stream tokens)
  35.   (setf *token-stream* tokens)
  36.   (setf *layout-stack* '())
  37.   (advance-token))
  38.  
  39. (define (advance-token)
  40.   (cond ((null? *token-stream*)
  41.      (setf *token* 'eof))
  42.     (else
  43.      (let* ((token (car *token-stream*)))
  44.        (setf *token-stream* (cdr *token-stream*))
  45.        (advance-token-1 (car token) (cdr token))))))
  46.  
  47. (define (advance-token-1 type args)
  48.   (cond ((eq? type 'file)
  49.      (setf *current-file* (car args))
  50.      (advance-token))
  51.     ((eq? type 'col)
  52.      (setf *current-col* (car args))
  53.      (advance-token))
  54.     ((eq? type 'line)  ;; assume blank lines have been removed
  55.      (let ((line (car args))
  56.            (col (cadr args)))
  57.        (setf *current-line* line)
  58.        (setf *current-col* col)
  59.        (setf *token-stream*
  60.          (resolve-layout *token-stream* *layout-stack*)))
  61.      (advance-token))
  62.     (else
  63.      (setf *token* type)
  64.      (setf *token-args* args)
  65.      type)))
  66.  
  67. (define (insert-extra-token tok-type stream) ; used by layout
  68.   (cons (list tok-type) stream))
  69.  
  70. ;;; This looks for the { to decide of layout will apply.  If so, the layout
  71. ;;; stack is pushed.  The body function, fn, is called with a boolean which
  72. ;;; tells it the whether layout rule is in force.
  73.  
  74. ;;; *** The CMU CL compiler barfs with some kind of internal error
  75. ;;; *** on this function.  See the revised definition below.
  76.  
  77. ;(define (start-layout fn)
  78. ;  (token-case
  79. ;   (\{ (funcall fn '#f))
  80. ;   (else
  81. ;    (let/cc recovery-fn
  82. ;      (push (cons *current-col* (lambda ()
  83. ;                  (let ((res (funcall fn '#t)))
  84. ;                    (funcall recovery-fn res))))
  85. ;        *layout-stack*)
  86. ;      (funcall fn '#t)))))
  87.  
  88. (define (start-layout fn)
  89.   (token-case
  90.    (\{ (funcall fn '#f))
  91.    (else
  92.     (let/cc recovery-fn
  93.       (start-layout-1 fn recovery-fn)))))
  94.  
  95. (define (start-layout-1 fn recovery-fn)
  96.   (when (and *layout-stack*
  97.          (<= *current-col* (layout-col (car *layout-stack*))))
  98.     (recoverable-error 'layout-problem
  99. "Declaration list is not indented further than outer list at line ~A in file ~A"
  100.       *current-line* *current-file*))
  101.   (push (cons *current-col*
  102.           (lambda ()
  103.         (let ((res (funcall fn '#t)))
  104.           (funcall recovery-fn res))))
  105.     *layout-stack*)
  106.   (funcall fn '#t))
  107.  
  108. (define (layout-col x)
  109.   (car x))
  110.  
  111. (define (layout-recovery-fn x)
  112.   (cdr x))
  113.  
  114. (define (close-layout in-layout?)
  115.   (cond (in-layout?
  116.      (setf *layout-stack* (cdr *layout-stack*))
  117.      (token-case
  118.       ($\} '())   ; the advance-token routine may have inserted this
  119.       (else '())))
  120.     (else
  121.      (token-case
  122.       (\} '())
  123.       (else
  124.        (signal-missing-brace))))))
  125.  
  126. (define (signal-missing-brace)
  127.   (parser-error 'missing-brace
  128.         "Missing `}'."))
  129.  
  130. (define (resolve-layout stream layout-stack)
  131.   (if (null? layout-stack)
  132.       stream
  133.       (let ((col  (layout-col (car layout-stack))))
  134.     (declare (type fixnum col))
  135.     (cond ((= (the fixnum *current-col*) col)
  136.            (insert-extra-token '\; stream))
  137.           ((< (the fixnum *current-col*) col)
  138.            (insert-extra-token
  139.              '$\} (resolve-layout stream (cdr layout-stack))))
  140.           (else
  141.            stream)
  142.           ))))
  143.     
  144.  
  145. ;;; The following routines are used for backtracking.  This is a bit of
  146. ;;; a hack at the moment.
  147.  
  148. (define (save-scanner-state)
  149.   (vector *token* *token-args* *token-stream* *layout-stack* *current-line*
  150.       *current-col*))
  151.  
  152. (define (restore-excursion state)
  153.   (setf *token* (vector-ref state 0))
  154.   (setf *token-args* (vector-ref state 1))
  155.   (setf *token-stream* (vector-ref state 2))
  156.   (setf *layout-stack* (vector-ref state 3))
  157.   (setf *current-line* (vector-ref state 4))
  158.   (setf *current-col* (vector-ref state 5)))
  159.  
  160. (define (eq-token? type)
  161.   (eq? type *token*))
  162.  
  163. (define (eq-token-arg? str)
  164.   (string=? str (car *token-args*)))
  165.  
  166. ;;; lookahead into the token stream
  167.  
  168. (define (peek-1-type)
  169.   (peek-toks 0 *token-stream*))
  170.  
  171. (define (peek-2-type)
  172.   (peek-toks 1 *token-stream*))
  173.  
  174. ;;; This is a Q&D way of looking ahead.  It does not expand the layout
  175. ;;; as it goes so there may be missing } and ;.  This should not matter
  176. ;;; in the places where this is used since these would be invalid anyway.
  177. ;;; To be safe, token types are rechecked while advancing to verify the
  178. ;;; lookahead.
  179.  
  180. (define (peek-toks n toks)
  181.   (declare (type fixnum n))
  182.   (cond ((null? toks)
  183.      'eof)
  184.     ((memq (caar toks) '(col line))
  185.      (peek-toks n (cdr toks)))
  186.     ((eqv? n 0)
  187.      (caar toks))
  188.     (else (peek-toks (1- n) (cdr toks)))))
  189.  
  190. ;; These routines handle the `satisfies' clauses used in token-case.
  191.  
  192. (define (at-varsym/+?)
  193.   (and (eq? *token* 'varsym)
  194.        (string=? (car *token-args*) "+")))
  195.  
  196. (define (at-varsym/-?)
  197.   (and (eq? *token* 'varsym)
  198.        (string=? (car *token-args*) "-")))
  199.  
  200. (define (at-varsym/paren?)
  201.   (and (eq? *token* '\()
  202.        (eq? (peek-1-type) 'varsym)
  203.        (eq? (peek-2-type) '\))))
  204.  
  205. (define (at-consym/paren?)
  206.   (and (eq? *token* '\()
  207.        (eq? (peek-1-type) 'consym)
  208.        (eq? (peek-2-type) '\))))
  209.  
  210. (define (at-varid/quoted?)
  211.   (and (eq? *token* '\`)
  212.        (eq? (peek-1-type) 'varid)))
  213.  
  214. (define (at-conid/quoted?)
  215.   (and (eq? *token* '\`)
  216.        (eq? (peek-1-type) 'conid)))
  217.  
  218. (define (at-+k?)
  219.   (and (at-varsym/+?)
  220.        (eq? (peek-1-type) 'integer)))
  221.  
  222. (define (at--n?)
  223.   (and (at-varsym/-?)
  224.        (memq (peek-1-type) '(integer float))))
  225.  
  226. ;;;  The following routines convert the simplest tokens to AST structure.
  227.  
  228. (define-local-syntax (return+advance x)
  229.   `(let ((x ,x))
  230.      (advance-token)
  231.      x))
  232.  
  233. (define (token->symbol)
  234.  (return+advance
  235.   (string->symbol (car *token-args*))))
  236.  
  237. (define (token->symbol/con)  ; for conid, aconid
  238.  (return+advance
  239.   (string->symbol (add-con-prefix (car *token-args*)))))
  240.  
  241. (define (var->symbol)
  242.   (token-case
  243.    (\( (token-case
  244.     (varsym?
  245.      (let ((res (token->symbol)))
  246.        (token-case
  247.         (\) res)
  248.         (else (signal-missing-token "`)'" "var")))))
  249.     (else (signal-missing-token "<varsym>" "var"))))
  250.    (varid? (token->symbol))))
  251.  
  252. (define (var->ast)
  253.   (let ((vname (var->symbol)))
  254.     (make var-ref (name vname) (infix? '#f) (var *undefined-def*))))
  255.  
  256. (define (var->entity) 
  257.   (let ((vname (var->symbol)))
  258.     (make entity-var (name vname))))
  259.  
  260. (define (con->symbol)
  261.   (token-case
  262.    (\( (token-case
  263.     (consym?
  264.      (let ((res (token->symbol/con)))
  265.        (token-case
  266.         (\) res)
  267.         (else (signal-missing-token "`)'" "con")))))
  268.     (else (signal-missing-token "<consym>" "con"))))
  269.    (conid? (token->symbol/con))))
  270.  
  271. (define (varop->symbol)
  272.   (token-case
  273.    (\` (token-case
  274.     (varid?
  275.      (let ((res (token->symbol)))
  276.        (token-case
  277.         (\` res)
  278.         (else (signal-missing-token "``'" "varop")))))
  279.     (else (signal-missing-token "<varid>" "varop"))))
  280.    (varsym? (token->symbol))))
  281.  
  282. (define (varop->ast)
  283.   (let ((varop-name (varop->symbol)))
  284.     (make var-ref (name varop-name) (infix? '#t) (var *undefined-def*))))
  285.  
  286. (define (conop->symbol)
  287.   (token-case
  288.    (\` (token-case
  289.     (conid?
  290.      (let ((res (token->symbol/con)))
  291.        (token-case
  292.         (\` res)
  293.         (else (signal-missing-token "``'" "conop")))))
  294.     (else (signal-missing-token "<conid>" "conop"))))
  295.    (consym? (token->symbol/con))))
  296.  
  297. (define (conop->ast)
  298.   (let ((conop-name (conop->symbol)))
  299.     (make con-ref (name conop-name) (infix? '#t) (con *undefined-def*))))
  300.  
  301. (define (op->symbol)
  302.   (token-case
  303.    (\` (token-case
  304.     (conid?
  305.      (let ((res (token->symbol/con)))
  306.        (token-case
  307.         (\` res)
  308.         (else (signal-missing-token "``'" "op")))))
  309.     (varid?
  310.      (let ((res (token->symbol)))
  311.        (token-case
  312.         (\` res)
  313.         (else (signal-missing-token "``'" "op")))))
  314.     (else (signal-missing-token "<conid> or <varid>" "op"))))
  315.    (consym? (token->symbol/con))
  316.    (varsym? (token->symbol))))
  317.  
  318. (define (con->ast)  ; for conid, aconid
  319.   (let ((name (con->symbol)))
  320.     (make con-ref (name name) (con *undefined-def*) (infix? '#f))))
  321.  
  322. (define (pcon->ast) ; for aconid, conid
  323.   (let ((name (con->symbol)))
  324.     (make pcon (name name) (con *undefined-def*) (pats '()) (infix? '#f))))
  325.  
  326. (define (pconop->ast) ; for aconop, conop
  327.   (let ((name (conop->symbol)))
  328.     (make pcon (name name) (con *undefined-def*) (pats '()) (infix? '#t))))
  329.  
  330. (define (tycon->ast) ; for aconid
  331.   (let ((name (token->symbol)))
  332.     (make tycon (name name) (def *undefined-def*) (args '()))))
  333.  
  334. (define (class->ast) ; for aconid
  335.   (let ((name (token->symbol)))
  336.     (make class-ref (name name) (class *undefined-def*))))
  337.  
  338. (define (tyvar->ast) ; for avarid
  339.   (let ((name (token->symbol)))
  340.     (make tyvar (name name))))
  341.  
  342. (define (token->integer) ; for integer
  343.  (return+advance
  344.   (car *token-args*)))
  345.  
  346. (define (integer->ast) ; for integer
  347.  (return+advance
  348.   (make integer-const (value (car *token-args*)))))
  349.  
  350. (define (float->ast)
  351.  (return+advance
  352.   (make float-const (numerator (car *token-args*))
  353.                 (denominator (cadr *token-args*))
  354.                 (exponent (caddr *token-args*)))))
  355.  
  356. (define (string->ast)
  357.  (return+advance
  358.   (make string-const (value (car *token-args*)))))
  359.  
  360. (define (char->ast)
  361.  (return+advance
  362.   (make char-const (value (car *token-args*)))))
  363.  
  364. (define (literal->ast)
  365.   (token-case
  366.     ((no-advance integer) (integer->ast))
  367.     ((no-advance float) (float->ast))
  368.     ((no-advance string) (string->ast))
  369.     ((no-advance char) (char->ast))))
  370.